home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / sptmbr11.lha / clx / bufmac.lisp < prev    next >
Lisp/Scheme  |  1991-06-14  |  7KB  |  189 lines
  1. ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
  2.  
  3. ;;; This file contains macro definitions for the BUFFER object for Common-Lisp
  4. ;;; X windows version 11
  5.  
  6. ;;;
  7. ;;;             TEXAS INSTRUMENTS INCORPORATED
  8. ;;;                  P.O. BOX 2909
  9. ;;;                   AUSTIN, TEXAS 78769
  10. ;;;
  11. ;;; Copyright (C) 1987 Texas Instruments Incorporated.
  12. ;;;
  13. ;;; Permission is granted to any individual or institution to use, copy, modify,
  14. ;;; and distribute this software, provided that this complete copyright and
  15. ;;; permission notice is maintained, intact, in all copies and supporting
  16. ;;; documentation.
  17. ;;;
  18. ;;; Texas Instruments Incorporated provides this software "as is" without
  19. ;;; express or implied warranty.
  20. ;;;
  21.  
  22. (in-package :xlib)
  23.  
  24. ;;; The read- macros are in buffer.lisp, because event-case depends on (most of) them.
  25.  
  26. (defmacro write-card8 (byte-index item)
  27.   `(aset-card8 (the card8 ,item) buffer-bbuf (index+ buffer-boffset ,byte-index)))
  28.  
  29. (defmacro write-int8 (byte-index item)
  30.   `(aset-int8 (the int8 ,item) buffer-bbuf (index+ buffer-boffset ,byte-index)))
  31.  
  32. (defmacro write-card16 (byte-index item)
  33.   #+clx-overlapping-arrays
  34.   `(aset-card16 (the card16 ,item) buffer-wbuf
  35.         (index+ buffer-woffset (index-ash ,byte-index -1)))
  36.   #-clx-overlapping-arrays
  37.   `(aset-card16 (the card16 ,item) buffer-bbuf
  38.         (index+ buffer-boffset ,byte-index)))
  39.  
  40. (defmacro write-int16 (byte-index item)
  41.   #+clx-overlapping-arrays
  42.   `(aset-int16 (the int16 ,item) buffer-wbuf
  43.            (index+ buffer-woffset (index-ash ,byte-index -1)))
  44.   #-clx-overlapping-arrays
  45.   `(aset-int16 (the int16 ,item) buffer-bbuf
  46.            (index+ buffer-boffset ,byte-index)))
  47.  
  48. (defmacro write-card32 (byte-index item)
  49.   #+clx-overlapping-arrays
  50.   `(aset-card32 (the card32 ,item) buffer-lbuf
  51.         (index+ buffer-loffset (index-ash ,byte-index -2)))
  52.   #-clx-overlapping-arrays
  53.   `(aset-card32 (the card32 ,item) buffer-bbuf
  54.         (index+ buffer-boffset ,byte-index)))
  55.  
  56. (defmacro write-int32 (byte-index item)
  57.   #+clx-overlapping-arrays
  58.   `(aset-int32 (the int32 ,item) buffer-lbuf
  59.            (index+ buffer-loffset (index-ash ,byte-index -2)))
  60.   #-clx-overlapping-arrays
  61.   `(aset-int32 (the int32 ,item) buffer-bbuf
  62.            (index+ buffer-boffset ,byte-index)))
  63.  
  64. (defmacro write-card29 (byte-index item)
  65.   #+clx-overlapping-arrays
  66.   `(aset-card29 (the card29 ,item) buffer-lbuf
  67.         (index+ buffer-loffset (index-ash ,byte-index -2)))
  68.   #-clx-overlapping-arrays
  69.   `(aset-card29 (the card29 ,item) buffer-bbuf
  70.         (index+ buffer-boffset ,byte-index)))
  71.  
  72. ;; This is used for 2-byte characters, which may not be aligned on 2-byte boundaries
  73. ;; and always are written high-order byte first.
  74. (defmacro write-char2b (byte-index item)
  75.   ;; It is impossible to do an overlapping write, so only nonoverlapping here.
  76.   `(let ((%item ,item)
  77.      (%byte-index (index+ buffer-boffset ,byte-index)))
  78.      (declare (type card16 %item)
  79.           (type array-index %byte-index))
  80.      (aset-card8 (the card8 (ldb (byte 8 8) %item)) buffer-bbuf %byte-index)
  81.      (aset-card8 (the card8 (ldb (byte 8 0) %item)) buffer-bbuf (index+ %byte-index 1))))
  82.  
  83. (defmacro set-buffer-offset (value &environment env)
  84.   env
  85.   `(let ((.boffset. ,value))
  86.      (declare (type array-index .boffset.))
  87.      (setq buffer-boffset .boffset.)
  88.      #+clx-overlapping-arrays
  89.      ,@(when (member 16 (macroexpand '(%buffer-sizes) env))
  90.      `((setq buffer-woffset (index-ash .boffset. -1))))
  91.      #+clx-overlapping-arrays
  92.      ,@(when (member 32 (macroexpand '(%buffer-sizes) env))
  93.      `((setq buffer-loffset (index-ash .boffset. -2))))
  94.      #+clx-overlapping-arrays
  95.      .boffset.))
  96.  
  97. (defmacro advance-buffer-offset (value)
  98.   `(set-buffer-offset (index+ buffer-boffset ,value)))
  99.  
  100. (defmacro with-buffer-output ((buffer &key (sizes '(8 16 32)) length index) &body body)
  101.   (unless (listp sizes) (setq sizes (list sizes)))
  102.   `(let ((%buffer ,buffer))
  103.      (declare (type display %buffer))
  104.      ,(declare-bufmac)
  105.      ,(when length
  106.     `(when (index>= (index+ (buffer-boffset %buffer) ,length) (buffer-size %buffer))
  107.        (buffer-flush %buffer)))
  108.      (let* ((buffer-boffset (the array-index ,(or index `(buffer-boffset %buffer))))
  109.         #-clx-overlapping-arrays
  110.         (buffer-bbuf (buffer-obuf8 %buffer))
  111.         #+clx-overlapping-arrays
  112.         ,@(append
  113.         (when (member 8 sizes)
  114.           `((buffer-bbuf (buffer-obuf8 %buffer))))
  115.         (when (or (member 16 sizes) (member 160 sizes))
  116.           `((buffer-woffset (index-ash buffer-boffset -1))
  117.             (buffer-wbuf (buffer-obuf16 %buffer))))
  118.         (when (member 32 sizes)
  119.           `((buffer-loffset (index-ash buffer-boffset -2))
  120.             (buffer-lbuf (buffer-obuf32 %buffer))))))
  121.        (declare (type array-index buffer-boffset))
  122.        #-clx-overlapping-arrays
  123.        (declare (type buffer-bytes buffer-bbuf)
  124.         (array-register buffer-bbuf))
  125.        #+clx-overlapping-arrays
  126.        ,@(append
  127.        (when (member 8  sizes)
  128.          '((declare (type buffer-bytes buffer-bbuf)
  129.             (array-register buffer-bbuf))))
  130.        (when (member 16 sizes)
  131.          '((declare (type array-index buffer-woffset))
  132.            (declare (type buffer-words buffer-wbuf)
  133.             (array-register buffer-wbuf))))
  134.        (when (member 32 sizes)
  135.          '((declare (type array-index buffer-loffset))
  136.            (declare (type buffer-longs buffer-lbuf)
  137.             (array-register buffer-lbuf)))))
  138.        buffer-boffset
  139.        #-clx-overlapping-arrays
  140.        buffer-bbuf
  141.        #+clx-overlapping-arrays
  142.        ,@(append
  143.        (when (member 8  sizes) '(buffer-bbuf))
  144.        (when (member 16 sizes) '(buffer-woffset buffer-wbuf))
  145.        (when (member 32 sizes) '(buffer-loffset buffer-lbuf)))
  146.        #+clx-overlapping-arrays
  147.        (macrolet ((%buffer-sizes () ',sizes))
  148.      ,@body)
  149.        #-clx-overlapping-arrays
  150.        ,@body)))
  151.  
  152. ;;; This macro is just used internally in buffer
  153.  
  154. (defmacro writing-buffer-chunks (type args decls &body body)
  155.   (when (> (length body) 2)
  156.     (error "writing-buffer-chunks called with too many forms"))
  157.   (let* ((size (* 8 (index-increment type)))
  158.      (form #-clx-overlapping-arrays
  159.            (first body)
  160.            #+clx-overlapping-arrays        ; XXX type dependencies
  161.            (or (second body)
  162.            (first body))))
  163.     `(with-buffer-output (buffer :index boffset :sizes ,(reverse (adjoin size '(8))))
  164.        ;; Loop filling the buffer
  165.        (do* (,@args
  166.          ;; Number of bytes needed to output
  167.          (len ,(if (= size 8)
  168.                `(index- end start)
  169.                `(index-ash (index- end start) ,(truncate size 16)))
  170.           (index- len chunk))
  171.          ;; Number of bytes available in buffer
  172.          (chunk (index-min len (index- (buffer-size buffer) buffer-boffset))
  173.             (index-min len (index- (buffer-size buffer) buffer-boffset))))
  174.         ((not (index-plusp len)))
  175.      (declare ,@decls
  176.           (type array-index len chunk))
  177.      ,form
  178.      (index-incf buffer-boffset chunk)
  179.      ;; Flush the buffer
  180.      (when (and (index-plusp len) (index>= buffer-boffset (buffer-size buffer)))
  181.        (setf (buffer-boffset buffer) buffer-boffset)
  182.        (buffer-flush buffer)
  183.        (setq buffer-boffset (buffer-boffset buffer))
  184.        #+clx-overlapping-arrays
  185.        ,(case size
  186.           (16 '(setq buffer-woffset (index-ash buffer-boffset -1)))
  187.           (32 '(setq buffer-loffset (index-ash buffer-boffset -2))))))
  188.        (setf (buffer-boffset buffer) (lround buffer-boffset))))) 
  189.